home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / Caml Light 0.61 / Source / src / compiler / compiler.ml < prev    next >
Encoding:
Text File  |  1994-07-07  |  6.3 KB  |  232 lines  |  [TEXT/MPS ]
  1. (* The compiler entry points *)
  2.  
  3. #open "obj";;
  4. #open "misc";;
  5. #open "const";;
  6. #open "lexer";;
  7. #open "parser";;
  8. #open "location";;
  9. #open "syntax";;
  10. #open "builtins";;
  11. #open "hashtbl";;
  12. #open "globals";;
  13. #open "modules";;
  14. #open "types";;
  15. #open "ty_error";;
  16. #open "typing";;
  17. #open "ty_decl";;
  18. #open "pr_decl";;
  19. #open "ty_intf";;
  20. #open "front";;
  21. #open "instruct";;
  22. #open "back";;
  23. #open "emit_phr";;
  24.  
  25. (* Parsing functions *)
  26.  
  27. let parse_phrase parsing_fun lexing_fun lexbuf =
  28.   let rec skip () =
  29.     try
  30.       match lexing_fun lexbuf with
  31.         EOF -> ()
  32.       | SEMISEMI -> ()
  33.       | _ -> skip()
  34.     with lexer__Lexical_error(_,_,_) ->
  35.       skip() in
  36.   try
  37.     parsing_fun lexing_fun lexbuf
  38.   with parsing__Parse_error f ->
  39.          let pos1 = lexing__get_lexeme_start lexbuf in
  40.          let pos2 = lexing__get_lexeme_end lexbuf in
  41.          if f (obj__repr EOF) or f (obj__repr SEMISEMI) then () else skip();
  42.          prerr_location (Loc(pos1, pos2));
  43.          prerr_begline " Syntax error.";
  44.          prerr_endline "";
  45.          raise Toplevel
  46.      | lexer__Lexical_error(msg, pos1, pos2) ->
  47.          if pos1 >= 0 & pos2 >= 0 then prerr_location (Loc(pos1, pos2));
  48.          prerr_begline " Lexical error: ";
  49.          prerr_string msg;
  50.          prerr_endline ".";
  51.          skip();
  52.          raise Toplevel
  53.      | Toplevel ->
  54.          skip ();
  55.          raise Toplevel
  56. ;;
  57.  
  58. let parse_impl_phrase = parse_phrase Implementation Main
  59. and parse_intf_phrase = parse_phrase Interface Main
  60. ;;
  61.  
  62. (* Executing directives *)
  63.  
  64. let do_directive = function
  65.     Zdir("open", name) ->
  66.       used_modules := find_module name :: !used_modules; ()
  67.   | Zdir("close", name) ->
  68.       used_modules := exceptq (find_module name) !used_modules; ()
  69.   | Zdir("infix", name) ->
  70.       add_infix name; ()
  71.   | Zdir("uninfix", name) ->
  72.       remove_infix name; ()
  73.   | Zdir("directory", dirname) ->
  74.       load_path := dirname :: !load_path
  75.   | Zdir(d, name) ->
  76.       prerr_begline " Warning: unknown directive \"";
  77.       prerr_string d;
  78.       prerr_endline2 "\", ignored."
  79. ;;
  80.  
  81. (* Compiling an interface *)
  82.  
  83. let verbose = ref false;;
  84.   
  85. let compile_intf_phrase (Intf(desc,loc)) =
  86.   begin match desc with
  87.     Zvaluedecl decl ->
  88.       type_valuedecl loc decl; ()
  89.   | Ztypedecl decl ->
  90.       let ty_decl = type_typedecl loc decl in
  91.       if !verbose then print_typedecl ty_decl
  92.   | Zexcdecl decl ->
  93.       let ex_decl = type_excdecl loc decl in
  94.       if !verbose then print_excdecl ex_decl
  95.   | Zintfdirective dir ->
  96.       do_directive dir
  97.   end
  98. ;;
  99.  
  100. let compile_interface modname filename =
  101.   let source_name = filename ^ ".mli"
  102.   and intf_name = filename ^ ".zi" in
  103.   let ic = open_in_bin source_name (* See compile_impl *)
  104.   and oc = open_out_bin intf_name in
  105.     try
  106.       start_compiling_interface modname;
  107.       let lexbuf = lexing__create_lexer_channel ic in
  108.       input_name := source_name;
  109.       input_chan := ic;
  110.       input_lexbuf := lexbuf;
  111.       external_types := [];
  112.       while true do
  113.         compile_intf_phrase(parse_intf_phrase lexbuf)
  114.       done
  115.     with End_of_file ->
  116.       close_in ic;
  117.       write_compiled_interface oc;
  118.       close_out oc
  119.     | x ->
  120.       close_in ic;
  121.       close_out oc;
  122.       remove_file intf_name;
  123.       raise x
  124. ;;
  125.  
  126. (* Compiling an implementation *)
  127.  
  128. let compile_impl_phrase outstream (Impl(desc,loc)) =
  129.   reset_type_expression_vars();
  130.   begin match desc with
  131.     Zexpr expr ->
  132.       let ty = type_expression loc expr in
  133.       emit_phrase outstream
  134.                   (expr_is_pure expr)
  135.                   (compile_lambda false (translate_expression expr));
  136.       if !verbose then print_expr ty
  137.   | Zletdef(rec_flag, pat_expr_list) ->
  138.       let env = type_letdef loc rec_flag pat_expr_list in
  139.       emit_phrase outstream
  140.          (letdef_is_pure pat_expr_list)
  141.          (if rec_flag
  142.           then compile_lambda true  (translate_letdef_rec loc pat_expr_list)
  143.           else compile_lambda false (translate_letdef loc pat_expr_list));
  144.       if !verbose then print_valdef env
  145.   | Ztypedef decl ->
  146.       let ty_decl = type_typedecl loc decl in
  147.       if !verbose then print_typedecl ty_decl
  148.   | Zexcdef decl ->
  149.       let ex_decl = type_excdecl loc decl in
  150.       if !verbose then print_excdecl ex_decl
  151.   | Zimpldirective dir ->
  152.       do_directive dir
  153.   end
  154. ;;
  155.  
  156. let compile_impl modname filename =
  157.   let source_name = filename ^ ".ml"
  158.   and obj_name = filename ^ ".zo" in
  159.   let ic = open_in_bin source_name
  160.   (* The source file must be opened in binary mode, so that the absolute
  161.      seeks in print_location work. The lexer ignores both \n and \r,
  162.      so this is OK on the Mac and on the PC. *)
  163.   and oc = open_out_bin obj_name in
  164.   let lexbuf = lexing__create_lexer_channel ic in
  165.     input_name := source_name;
  166.     input_chan := ic;
  167.     input_lexbuf := lexbuf;
  168.     start_emit_phrase oc;
  169.     try
  170.       while true do
  171.         compile_impl_phrase oc (parse_impl_phrase lexbuf)
  172.       done
  173.     with End_of_file ->
  174.       end_emit_phrase oc;
  175.       close_in ic;
  176.       close_out oc
  177.     | x ->
  178.       close_in ic;
  179.       close_out oc;
  180.       remove_file obj_name;
  181.       raise x
  182. ;;
  183.  
  184. let write_extended_zi = ref false;;
  185.  
  186. let compile_implementation modname filename =
  187.   external_types := [];
  188.   if file_exists (filename ^ ".mli") then begin
  189.     try
  190.       if not (file_exists (filename ^ ".zi")) then begin
  191.         prerr_begline " Cannot find file ";
  192.         prerr_string filename;
  193.         prerr_string ".zi. Please compile ";
  194.         prerr_string filename;
  195.         prerr_endline ".mli first.";
  196.         raise Toplevel
  197.       end;
  198.       let intf = read_module (filename ^ ".zi") in
  199.       start_compiling_implementation modname intf;
  200.       enter_interface_definitions intf;
  201.       compile_impl modname filename;
  202.       check_interface intf;
  203.       if !write_extended_zi then begin
  204.         let ext_intf_name = filename ^ ".zix" in
  205.         let oc = open_out_bin ext_intf_name in
  206.         try
  207.           write_compiled_interface oc;
  208.           close_out oc
  209.         with x ->
  210.           close_out oc;
  211.           remove_file (ext_intf_name);
  212.           raise x
  213.       end;
  214.       kill_module modname
  215.     with x ->
  216.       remove_file (filename ^ ".zo");
  217.       raise x
  218.   end else begin
  219.     let intf_name = filename ^ ".zi" in
  220.     let oc = open_out_bin intf_name in
  221.     try
  222.       start_compiling_interface modname;
  223.       compile_impl modname filename;
  224.       write_compiled_interface oc;
  225.       close_out oc
  226.     with x ->
  227.       close_out oc;
  228.       remove_file intf_name;
  229.       raise x
  230.   end
  231. ;;
  232.